Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-04/modula2f.zip/WINDOWS.MOD

Text File | 1992-06-24 | 10KB | 421 lines

IMPLEMENTATION MODULE Windows;

FROM SYSTEM IMPORT ASSEMBLER;
FROM Strings IMPORT Length;
FROM Text IMPORT Color, GetKey, Write, SetCursor;
FROM Screen IMPORT SaveScreen, RestoreScreen;

VAR watr:CARDINAL;
    current:Window;

PROCEDURE Clw();
    VAR up,dn,lf,rt:CARDINAL;
    BEGIN
        up:=current.t;
        dn:=current.b;
        lf:=current.l;
        rt:=current.r;
        ASM
            MOV CH,up
            MOV CL,lf
            MOV DH,dn
            MOV DL,rt
            MOV BH,watr
            XOR AL,AL
            MOV AH,6
            INT 10H
            MOV DH,up
            MOV DL,lf
            XOR BH,BH
            MOV AH,2
            INT 10H
        END;
     END Clw;

PROCEDURE WSetCursor(v,h:CARDINAL);
    BEGIN
        v:=v+current.t;
        h:=h+current.l;
        IF v>current.b THEN
            v:=current.b;
        END; (* if *)
        IF h>current.r THEN
            h:=current.r;
        END;
        SetCursor(v,h);
    END WSetCursor;

PROCEDURE MakeWindow(v,h,height,width,fcolor,bcolor:CARDINAL;
                     title:Title; VAR w:Window);
    BEGIN
        w.t:=v;
        w.b:=v+height-1;
        w.l:=h;
        w.r:=h+width-1;
        w.fc:=fcolor;
        w.bc:=bcolor;
        w.ttl:=title;
    END MakeWindow;

PROCEDURE GetAttrib(VAR oatr:CARDINAL);
    BEGIN
        ASM
            LES DI,oatr
            XOR BH,BH
            MOV AH,8
            INT 10H
            MOV ES:[DI],AH
        END;
    END GetAttrib;

PROCEDURE SetWindow(VAR w:Window);
    BEGIN
        current.t := w.t;
        current.b := w.b;
        current.l := w.l;
        current.r := w.r;
        watr := (w.bc MOD 8) * 16 + (w.fc MOD 16);
    END SetWindow;

PROCEDURE PutWindow(VAR w:Window);
    VAR h,v,f,b,i:CARDINAL;
    BEGIN
        SetWindow(w);
        SaveScreen(w.dat);

            (* draw border *)

        v:=w.t-1; h:=w.l-1;
        SetCursor(24,0);
        GetAttrib(i);
        f:=i MOD 16;
        b:=i DIV 16;
        SetCursor(v,h);
        Color(w.fc,w.bc);
        Write(CHR(201));
        IF Length(w.ttl)>0 THEN
            Write(CHR(181));
            INC(h);
            FOR i:=0 TO Length(w.ttl)-1 DO
                Write(w.ttl[i]);
                INC(h);
            END; (* for *)
            Write(CHR(198));
            INC(h);
        END; (* if *)
        WHILE h<w.r DO
            Write(CHR(205));
            INC(h);
        END; (* while *)
        Write(CHR(187));
        FOR v:=w.t TO w.b DO
            SetCursor(v,w.l-1);
            Write(CHR(186));
            SetCursor(v,w.r+1);
            Write(CHR(186));
        END; (* for *)
        SetCursor(w.b+1,w.l-1);
        Write(CHR(200));
        FOR h:=w.l TO w.r DO
            Write(CHR(205));
        END; (* for *)
        Write(CHR(188));

        Clw;

        Color(f,b);
    END PutWindow;

PROCEDURE RemoveWindow(VAR w:Window);
    VAR f,b,i:CARDINAL;
    BEGIN
        RestoreScreen(w.dat);
    END RemoveWindow;

PROCEDURE ScrollUp(count:CARDINAL);
    VAR up,dn,lf,rt:CARDINAL;
    BEGIN
        up:=current.t;
        dn:=current.b;
        lf:=current.l;
        rt:=current.r;
        ASM
            MOV CH,up
            MOV CL,lf
            MOV DH,dn
            MOV DL,rt
            MOV BH,watr
            MOV AL,count
            MOV AH,6
            INT 10H
            MOV DH,up
            MOV DL,lf
            XOR BH,BH
            MOV AH,2
            INT 10H
        END;
    END ScrollUp;

PROCEDURE ScrollDown(count:CARDINAL);
    VAR up,dn,lf,rt:CARDINAL;
    BEGIN
        up:=current.t;
        dn:=current.b;
        lf:=current.l;
        rt:=current.r;
        ASM
            MOV CH,up
            MOV CL,lf
            MOV DH,dn
            MOV DL,rt
            MOV BH,watr
            MOV AL,count
            MOV AH,7
            INT 10H
            MOV DH,up
            MOV DL,lf
            XOR BH,BH
            MOV AH,2
            INT 10H
        END;
    END ScrollDown;

PROCEDURE WRead(VAR ch:CHAR);
    VAR key,scan:CHAR;
    BEGIN
        GetKey(key,scan);
        WWrite(key);
        ch:=key;
    END WRead;

PROCEDURE WReadCard(VAR n:CARDINAL);
    VAR str:ARRAY [0..5] OF CHAR;
          i:CARDINAL;
    BEGIN
        WReadString(str);
        n:=0;
        IF Length(str) > 0 THEN
            FOR i:=0 TO Length(str)-1 DO
                IF (str[i] >= '0') AND (str[i] <= '9') THEN
                    n:=10*n+(ORD(str[i])-ORD('0'));
                END; (* if *)
            END; (* for *)
       END; (* if *)
    END WReadCard;

PROCEDURE WReadInt(VAR i:INTEGER);
    VAR str:ARRAY [0..6] OF CHAR;
        c:CHAR;
        x:CARDINAL;
        p:INTEGER;
        neg:BOOLEAN;
    BEGIN
        WReadString(str);
        neg:=FALSE;
        i:=0; p:=0;
        IF Length(str) > 0 THEN
            x:=0;
            IF str[x] = "-" THEN
                neg:=TRUE; INC(x);
            END; (* if *)
            WHILE x < Length(str) DO
                IF (str[x] >= '0') AND (str[x] <= '9') THEN
                    p:=10*p; c:=str[x];
                    ASM
                        XOR AX,AX
                        MOV AL,c
                        SUB AX,48
                        ADD p,AX
                    END;
                    (* (ORD(str[x])-ORD('0')); *)
                END; (* if *)
                INC(x);
            END; (* while *)
        END; (* if *)
        IF neg THEN
            p:=-1*p;
        END; (* if *)
        i:=p;
    END WReadInt;

PROCEDURE WReadString(VAR str:ARRAY OF CHAR);
    VAR i:CARDINAL;
        ch,sc:CHAR;
    BEGIN
        i:=0;
        GetKey(ch,sc);
        WHILE ch<>CHR(13) DO
            IF (sc=CHR(14)) OR (sc=CHR(75)) THEN
                IF i>0 THEN
                    DEC(i);
                    ASM
                        MOV AL,8
                        MOV AH,14
                        INT 10H
                        MOV AL,32
                        MOV AH,14
                        INT 10H
                        MOV AL,8
                        MOV AH,14
                        INT 10H
                    END;
                END; (* if *)
            ELSE
                WWrite(ch);
                str[i]:=ch;
                INC(i);
            END; (* if *)
            GetKey(ch,sc);
        END; (* while *)
        str[i]:=CHR(0);
        WWriteLn;
    END WReadString;

PROCEDURE WWriteString(str:ARRAY OF CHAR);
    VAR i:CARDINAL;

    BEGIN
        IF Length(str) > 0 THEN
            FOR i:=0 TO Length(str)-1 DO
                WWrite(str[i]);
            END; (* for *)
        END; (* if *)
    END WWriteString;

PROCEDURE WWriteCard(n,lngth:CARDINAL);
    VAR buf:ARRAY [1..10] OF CHAR;
        ln:CARDINAL;
    BEGIN
        IF lngth > 10 THEN
            lngth:=10;
        END; (* if *)
        FOR ln:=1 TO 10 DO
            buf[ln]:=CHR(0);
        END; (* for *)
        ln:=lngth;
        buf[ln]:='0';
        WHILE (n>0) AND (ln>0) DO
            buf[ln]:=CHR((n MOD 10) + 48);
            n:=n DIV 10;
            DEC(ln);
        END; (* while *)
        FOR n:=1 TO lngth DO
            WWrite(buf[n]);
        END; (* for *)
    END WWriteCard;

PROCEDURE WWriteInt(n:INTEGER; lngth:CARDINAL);
    VAR buf:ARRAY [1..10] OF CHAR;
        ln,c:CARDINAL;
        neg:BOOLEAN;
    BEGIN
        IF lngth > 10 THEN
            lngth:=10;
        END; (* if *)
        FOR ln:=1 TO 10 DO
            buf[ln]:=CHR(0);
        END; (* for *)
        IF n<0 THEN
            neg:=TRUE;
            n:=-n;
        ELSE
            neg:=FALSE;
        END; (* if *)
            ASM
                MOV AX,n
                MOV c,AX
            END;
        ln:=lngth;
        buf[ln]:='0';
        WHILE (c>0) AND (ln>0) DO
            buf[ln]:=CHR((c MOD 10)+48);
            c:=c DIV 10;
            DEC(ln);
        END; (* while *)
        IF (ln>0) AND neg THEN
            buf[ln]:='-';
            DEC(ln);
        END; (* if *)
        FOR ln:=1 TO lngth DO
            WWrite(buf[ln]);
        END; (* for *)
    END WWriteInt;

PROCEDURE WWrite(ch:CHAR);
    VAR rt,dn,lf,up:CARDINAL;
    BEGIN
        lf:=current.l;
        dn:=current.b;
        rt:=current.r;
        up:=current.t;
        ASM
            MOV CX,1
            MOV BL,watr
            XOR BH,BH
            MOV AL,ch
            MOV AH,9
            INT 10H
            MOV AH,3
            INT 10H
            INC DL
            MOV CL,DL
            XOR CH,CH
            CMP CX,rt
            JLE SETC
            MOV DL,lf
            INC DH
            MOV CL,DH
            CMP CX,dn
            JLE SETC
            MOV BH,watr
            MOV CH,up
            MOV CL,lf
            MOV DH,dn
            MOV DL,rt
            MOV AL,1
            MOV AH,6
            INT 10H
            MOV DL,lf
    SETC:   MOV AH,2
            INT 10H
        END;
    END WWrite;

PROCEDURE WWriteLn();
    VAR lf,dn,rt,up:CARDINAL;
    BEGIN
        lf:=current.l;
        dn:=current.b;
        rt:=current.r;
        up:=current.t;
        ASM
            XOR BH,BH
            MOV AH,3
            INT 10H
            INC DH
            CMP DH,dn
            JLE SETC
            MOV BH,watr
            MOV CH,up
            MOV CL,lf
            MOV DH,dn
            MOV DL,rt
            MOV AL,1
            MOV AH,6
            INT 10H
    SETC:   MOV DL,lf
            MOV AH,2
            INT 10H
        END;
    END WWriteLn;

BEGIN
    watr:=7;
    current.t:=0;
    current.b:=24;
    current.l:=0;
    current.r:=79;
    current.fc:=7;
    current.bc:=0;
    current.ttl:='';
END Windows.